;;; queue.ss  --  Jens Axel Soegaard  --  2003/2004

; Queues and deques (double ended queues). 

;   Default queue:   queue@    ( batched-queue@ )
;   Default dequeue: deque@    ( batched-deque@ )

; NOTES
;   For applications which don't need persistence and
;   more than amortized time bounds is uneeded,
;   the batched queue/deque is the best choice.

(module queue mzscheme
  (require (lib "unitsig.ss" "mzlib")
           (lib "list.ss" "mzlib"))
  
  (provide (all-defined))
  
  ;;; SIGNATURES
  
  ; Queue
  (define-signature queue^    
    (empty
     empty?
     insert
     insert-last
     remove
     remove-first
     first
     elements
     fold
     ))
  
  ; Double Ended Queue
  (define-signature deque^    
    ((open queue^)
     insert-first
     remove-last
     last))
  
  (define-syntax (use-queue stx)
    (syntax-case stx ()
      [(use-queue unit)      
       (datum->syntax-object stx `(,#`define-values/invoke-unit/sig queue^ ,#`unit))]
      [(use-queue unit prefix)
       (datum->syntax-object stx `(,#`define-values/invoke-unit/sig queue^ ,#`unit ,#`prefix))]))
  
  (define-syntax (use-deque stx)
    (syntax-case stx ()
      [(use-dequeue unit)   
       (datum->syntax-object stx `(,#`define-values/invoke-unit/sig deque^ ,#`unit))]
      [(use-dequeue unit prefix)
       (datum->syntax-object stx `(,#`define-values/invoke-unit/sig deque^ ,#`unit ,#`prefix))]))
  
  
  ;;; BATCHED QUEUE
  
  ; Reference: [Oka,43]
  
  ; Timings:   empty?         O(1) wc
  ;            insert         O(1) amortized
  ;            remove-first   O(1) amortized
  ;            first          O(1) wc
  
  (define batched-queue@
    (unit/sig queue^ 
      (import)
      
      (define-struct queue (front rear))
      
      ; Invariants
      ;   1.  q empty <=> (null? (queue-front q))
      ;   2.  elements of q  =  (append (queue-front q) (reverse (queue-rear q)))
      
      (define empty (make-queue '() '()))
      
      (define (empty? q)
        (null? (queue-front q)))
      
      (define (insert-last q x)
        (let ([front (queue-front q)])
          (if (null? front)
              (make-queue (list x) '())
              (make-queue front (cons x (queue-rear q))))))
      
      (define insert insert-last)
      
      (define (remove-first q)
        (let ([front (queue-front q)])
          (if (null? front)
              (error "remove-first: can't remove element from empty queue; given " q)
              (if (null? (cdr front))
                  (make-queue (reverse (queue-rear q)) '())
                  (make-queue (cdr front) (queue-rear q))))))
      
      (define remove remove-first)
      
      (define (first q)
        (if (empty? q)
            (error "first: There is no first element in an empty queue; given " q))
        (car (queue-front q)))
      
      (define (elements q)
        (append (queue-front q) (reverse (queue-rear q))))
      
      (define (fold f init q)
        (foldl f 
               (foldl f init (queue-front q))
               (reverse (queue-rear q))))
      ))
  
  ;;; DOUBLE ENDED BATCHED QUEUE
  
  ; Reference: Exercise 5.1 in [Oka]. (Hoogerwoord 92)
  
  (define batched-deque@
    (unit/sig deque^ 
      (import)
      
      (define-struct deque  (front rear))
      
      ; Invariants
      ;   1.  q empty         <=>  (null? (deque-front q))
      ;   2.  (size q) >= 2   <=>  (and (null? (deque-front q)) 
      ;                                 (null? (deque-rear q))
      ;   3.  elements of q  =  (append (deque-front q) (reverse (deque-rear q)))
      
      (define empty (make-deque '() '()))
      
      (define (empty? q)
        (null? (deque-front q)))
      
      (define (split l)
        (define (take n f r)
          (if (= n 0)
              (list (reverse f) r)
              (take (sub1 n) (cons (car r) f) (cdr r))))
        (let ([n (length l)])
          (take (quotient n 2) '() l)))      
      
      (define (check-invariant q)
        (let ([f (deque-front q)]
              [r (deque-rear q)])
          (cond
            [(and (or (null? f) 
                      (null? (cdr f))) 
                  (null? r))            q]
            [(null? f)                  (let* ([h  (split r)]
                                               [fh (car h)]
                                               [sh (cadr h)])
                                          (make-deque (reverse sh)  fh))]
            [(null? r)                  (let* ([h  (split f)]
                                               [fh (car h)]
                                               [sh (cadr h)])
                                          (make-deque fh  (reverse sh)))]
            [else q])))
      
      (define (insert-first q x)
        (check-invariant (make-deque (cons x (deque-front q)) 
                                     (deque-rear q))))
      
      (define (insert-last q x)
        (check-invariant (make-deque (deque-front q) 
                                     (cons x (deque-rear q)))))
      
      (define insert insert-last) 
      
      (define (remove-first q)
        (if (null? (deque-front q))
            (error "remove-first: can't remove element from empty deque; given " q)
            (check-invariant (make-deque (cdr (deque-front q)) (deque-rear q)))))
      
      (define (remove-last q)
        (if (null? (deque-rear q))
            (remove-first q) 
            (check-invariant (make-deque (deque-front q) (cdr (deque-rear q))))))   
      
      (define (last q)
        (if (empty? q)
            (error "last: There is no last element in an empty deque; given " q))
        (cond
          [(null? (deque-rear q))  (first q)]
          [else                    (car (deque-rear q))]))
      
      (define remove remove-first)
      
      (define (first q)
        (if (empty? q)
            (error "first: There is no first element in an empty queue; given " q))
        (car (deque-front q)))
      
      (define (elements q)
        (append (deque-front q) (reverse (deque-rear q))))
      
      (define (fold f init q)
        (foldl f 
               (foldl f init (deque-front q))
               (reverse (deque-rear q))))
      ))
  
  ;;; BANKER'S QUEUES
  
  ; [Oka, p.64-67]
  ; The queues are an efficient persistent implementation of queues,
  ; every operation runs in O(1) amortized time.
  
  ;(define-signature queue^    
  ;  (empty
  ;   empty?
  ;   insert  insert-last
  ;   remove  remove-first
  ;   first))
  
  (define bankers-queue@
    (unit/sig queue^ 
      (import)
      
      (define-struct queue (front-length front rear-length rear))
      
      (define fl queue-front-length)
      (define f  queue-front)
      (define rl queue-rear-length)
      (define r  queue-rear)
      
      ; Lazy stream
      
      (define lempty (delay '()))
      
      (define (lcons x stream)
        (delay (cons x stream)))
      
      (define (fcar stream)
        (car (force stream)))
      
      (define (fcdr stream)
        (cdr (force stream)))
      
      (define (lappend pl1 pl2)
        (let ([l1 (force pl1)])
          (if (null? l1)
              pl2
              (let ([l2 (force pl2)])
                (if (null? l2)
                    pl1
                    (lcons (car l1)
                           (lappend (cdr l1) pl2)))))))
      
      (define (lreverse pl)
        (define (loop pl pr)
          (let ([l (force pl)])
            (if (null? l)
                pr
                (loop (cdr l) (lcons (car l) pr)))))
        (loop pl lempty))
      
      ; Queue operations
      
      (define (insert-last q x)
        (check (fl q) (f q) (add1 (rl q)) (lcons x (r q))))
      
      (define insert insert-last)
      
      (define (first q)
        (if (empty? q)
            (error "first: There is no first element in an empty queue; given " q))
        (fcar (f q)))
      
      (define (rest q)
        (check (sub1 (fl q)) (fcdr (f q)) (rl q) (r q)))
      
      (define (remove-first q)
        (if (empty? q)
            (error "remove-first: There is no first element in an empty queue; given " q))
        (rest q))

      (define remove remove-first)
      
      (define (check fl f rl r)
        (if (<= rl fl)
            (make-queue fl f rl r)
            (make-queue (+ fl rl) (lappend f (lreverse r)) 0 lempty)))
      
      (define (empty? q)
        (and (= 0 (fl q) (rl q))))
      
      (define empty (make-queue 0 (delay '()) 0 (delay '())))
      
      (define (fold f b q)
        (define (loop q a)
          (if (empty? q)
              a
              (loop (rest q) (f (first q) a))))
        (loop q b))
      
      (define (elements q)
        (fold cons '() q))))
  
  ;; DEFAULTS
  
  (define queue@ batched-queue@)
  (define deque@ batched-deque@)
  
  )